perm filename GETPTS.F4[PAG,LCS] blob sn#598961 filedate 1981-07-12 generic text, type T, neo UTF8
00100	 	SUBROUTINE GETPTS(NX,RN,KWDS)
00200	C  'NX' DOES NOT SEEM TO BE USED
00300		DIMENSION RN(1),KWDS(1)
00400		COMMON/KNR/N(1) /NNP/NP(1) /LLL/LLL
00500		COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS
00600		COMMON/POSI/STFF(8),JJ2,JPQ /KJY/ K,J
00700		EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3))
00800	
00900			J=0
01000			K=0
01100	CC	JX=JJ2
01200	C GET THE STAFF NUM. (NEG= ALL IN THIS PROG.)
01300		DO 1 M=1,LLL
01400		L=KWDS(M)
01500		IF(R2.LT.0)GO TO 9
01600		IF(RN(L+1).NE.R2)GO TO 1
01700	C NEG R2=ALL STAVES   CHECK NOW FOR CORRECT STAFF
01800	
01900	9	X=RN(L+3)
02000		IF(X.LT.R4.OR.X.GT.R5)GO TO 2
02100	C NOW P3 IS IN LIMITS
02200		IF(JJ2.LE.0)JJ2=M
02300		J=J+1
02400	CC	MOVEI	0,(L)
02500		K=K+1
02600		NP(K)=L
02700	C  NP LIST POINTS TO START OF EACH ITEM TO MOVE
02800		N(J)=L+3
02900	C  N LIST POINTS TO PARAM TO BE MOVED
03000	C  NP IS FOR USE IN JUSTIFY ROUTINE
03100	2	RY=RN(L+1)
03200	C  RY IS CODE NUMBER OF ITEM
03300		IF(RY.EQ.2.)GO TO 99
03400	C JUMP IF REST
03500		IF(RY.LT.4)GO TO 1
03600		RZ=RN(L)
03700	C RZ IS WDCNT.   CODE 4 IS SOMETIMES =44
03800		IF(RY.NE.44.)GO TO 98
03900		IF(RZ.LE.2.)GO TO 1
04000		GO TO 5
04100	C IF(RZ.LE.2)THEN IT'S A CODE 44 BAR LINE.
04200	C FOUND A LINE
04300	98	IF(RY.GT.7.)GO TO 1
04400	C  TWO-ENDED ITEM?
04500		GO TO (4,5,6,7),IFIX(RY)-3
04600	7	IF(RZ.GT.4.)GO TO 1
04700	C  FOR TRILL??
04800	4	IF(RZ.GT.3.)GO TO 5
04900	C CHECK WDCNT
05000		GO TO 1
05100	99	RZ=RN(L)
05200	C FOR 'CENTERED' RESTS
05300		GO TO 8
05400	6	IF(RZ.LT.8.)GO TO 8
05500		IF(RN(L+7).LT.0)GO TO 8
05600	C  THESE ARE FOR VARIOUS BEAM PARAMS.
05700		IF(RN(L+10).EQ.0)GO TO 8
05800	C IGNORE P8 IF IT IS 0 OR -
05900		X=RN(L+8)
06000		IF(X.LE.0)GO TO 8
06100		IF(X.LT.R4)GO TO 8
06200		IF(X.GT.R5)GO TO 8
06300	C NOW P8 IS IN LIMITS
06400		CALL SETN(L+8,M)
06500	C  FIND LOWEST ITEM NUMBER NEEDED
06600	C SAVE POINTER TO P8 FOR MOVING.
06700	8	IF(RZ.LT.7.)GO TO 5
06800	C JUMP IF WDCNT IS .LT. 7
06900		IF(RN(L+9).LE.0)GO TO 5
07000		IF(RY.EQ.2.)GO TO 97  
07100	C NEW CENTERED RESTS  HAS POSITION IN P9
07200		IF(RN(L+8).NE.0)GO TO 97
07300		IF(RN(L+7).GE.0)GO TO 5
07400	97	X=RN(L+9)
07500		IF(X.LT.R4)GO TO 5
07600		IF(X.GT.R5)GO TO 5
07700	C  NOW P9 IS IN LIMITS
07800		CALL SETN(L+9,M)
07900	5	IF(RY.EQ.2.)GO TO 1  
08000		X=RN(L+6)
08100		IF(X.LT.R4)GO TO 1
08200		IF(X.GT.R5)GO TO 1
08300	C  NOW P6 IS IN LIMITS
08400		CALL SETN(L+6,M)
08500	1	CONTINUE
08600		END
08700	
08800		SUBROUTINE SETN(L,M)
08900		COMMON/POSI/STFF(8),JJ2 /KJY/ K,J /KNR/N(1)
09000		IF(JJ2.GT.M)JJ2=M
09100	C  FIND LOWEST ITEM NUMBER NEEDED
09200		J=J+1
09300		N(J)=L
09400		END
09500		SUBROUTINE MOVIT(RN,NP,R4,R5,R8,R9)
09600		DIMENSION  NP(1),RN(1)
09700		COMMON  /KJY/ KD,J
09800		RDIS=(R9-R8)/(R5-R4)
09900		DO 1 K=1,J
10000		L=NP(K)
10100		RA=RN(L)
10200		IF(RA.LT.R4)GO TO 1
10300		IF(RA.GT.R5)GO TO 1
10400	C  NOW IN BOUNDS
10500		IF(R9.NE.0)RA=(RA-R4)*RDIS
10600		RN(L)=R8+RA
10700	1	CONTINUE
10800		END
10900	
11000		FUNCTION EXTEN(X)
11100		EXTEN=AMOD(X,1.)*10.
11200		END
11300	
11400		SUBROUTINE DBAR(K,ITEM,J)
11500		COMMON /XRN/RN(1) /RR/RR /PTR/KWDS(1)
11600	
11700		RR=RN(J+3)
11800	C  SAVE POSITION OF ITEM.  ALSO USED IN ADRST ROUTINE.
11900		DO 82 KY=K+1,ITEM
12000		KZ=KWDS(KY)
12100		IF(RN(KZ+1).NE.4.)GO TO 82
12200		IF(RN(KZ).GT.3.)GO TO 82
12300	C  CHECK THE WDCNT
12400		IF(ABS(RR-RN(KZ+3)).GT..5)GO TO 82	
12500	C  AVOIDS DUPLICATE BARS.
12600		RN(KZ+2)=99.
12700		RN(KZ+1)=0
12800	82	CONTINUE
12900		END
13000	
13100	
13200		SUBROUTINE ADRST(JWDS,RA)
13300		COMMON /XXX/LK,LP,JY /Q/Q(1) /RR/RR  /LLL/LLL 
13400		DIMENSION JWDS(1)
13500	
13600		Q(LK)=6.
13700		Q(LK+1)=2.
13800	C SET UP THE REST
13900		Q(LK+2)=0
14000		Q(LK+3)=RR-1.
14100	C GET POSITION FROM ROUTINE ABOVE
14200		Q(LK+4)=0
14300		Q(LK+5)=0
14400		Q(LK+6)=0
14500		Q(LK+7)=6.
14600		Q(LK+8)=-1.
14700	C NEXT ADDS A BAR LINE
14800		LK=LK+9
14900		JWDS(LLL+1)=LK
15000	CHECK THIS ******************
15100		Q(LK)=2.
15200		Q(LK+1)=4.
15300		Q(LK+2)=0
15400		Q(LK+3)=RR
15500		Q(LK+4)=RA
15600		LK=LK+5
15700		JWDS(LLL+2)=LK
15800		LLL=LLL+2
15900		END
16000	
16100		SUBROUTINE QRN(J,JWDS,K)
16200		DIMENSION JWDS(1)
16300		COMMON RS,JA,REST,J2,RQ(2),R5
16400		COMMON /XRN/RN(1) /PTR/KWDS(1) /XXX/LK /Q/Q(1) /LLL/LLL
16500		COMMON /RCLF/RCLF,CLEF /SF/KL
16600		JA=KWDS(K+1)
16700		LX=LK
16800		DO 7 KY=J,JA-1
16900		Q(LK)=RN(KY)
17000	7	LK=LK+1
17100		IF(KL.EQ.0)GO TO 5
17200	C PUT A 1.0 AS RHYTHM FOR REST OR NOTE
17300		LK=LK+KL-1
17400		Q(LK)=1.
17500	C PUT IT IN PARAM 7 OR 9
17600	CC5	LK=LK+1
17700	5	IF(R5.LT.0)GO TO 2
17800		Q(LX+5)=R5
17900		WDC=3.
18000	3	LK=LK+WDC-Q(LX)
18100	C  UPDATE THE MAIN COUNTER
18200		Q(LX)=WDC
18300		GO TO 1
18400	2	IF(RCLF.NE.17.)GO TO 1
18500		Q(LX+6)=CLEF
18600	C  GET THE CLEF NUM.
18700		WDC=4.
18800		GO TO 3
18900	1	JWDS(LLL+1)=LK
19000		LLL=LLL+1
19100		END
19200	
19300		SUBROUTINE SORT(JWDS)
19400		DIMENSION JWDS(1)
19500		COMMON /LLL/LLL /Q/Q(1) /XRN/RN(1) /PTR/KWDS(1)
19600		I=1
19700		DO 243 K=1,LLL-1
19800		LB=JWDS(K)+1
19900		IF(Q(LB).NE.16.)GO TO 243
20000		IF(Q(LB-1).LT.8.)GO TO 243
20100		JL=JWDS(K-1)
20200	244	Q(LB+2)=Q(JL+3)
20300	243    CONTINUE
20400	
20500	C PUTS CONTINUATION OF TEXT IMMEDIATELY AFTER PREV. POS.
20600	C   FOR SPACING PROBLEMS BELOW.
20700		M=2
20800		J=1
20900	24	RA=100000.
21000	C  POSITION
21100		DO 21 K=1,LLL-1
21200		JL=JWDS(K)+3
21300		R=Q(JL)
21400		IF(R.EQ.100000.)GO TO 21
21500	241	IF(ABS(R-RA).GT..1)GO TO 240
21600		Q(JL)=RA
21700		GO TO 21
21800	CC PUT IN HERE MULTI-VOICE TRAP SOMEDAY
21900	240	IF(R.GT.RA)GO TO 21
22000	C  LINES THEM UP
22100		RA=R
22200	CC	I=JL-3
22300		I=K
22400	21	CONTINUE
22500		IF(RA.EQ.100000.)RETURN
22600	C  JUMP IF ALL SORTED
22700	242	JL=JWDS(I)
22800		LA=JL
22900		N=Q(JL)+3
23000		KWDS(M)=KWDS(M-1)+N
23100		M=M+1
23200		DO 22 K=J,J+N-1
23300		RN(K)=Q(JL)
23400	22	JL=JL+1
23500		J=J+N
23600		Q(LA+3)=100000.
23700		GO TO 24
23800		END
23900	
24000		SUBROUTINE SHIFT
24100		COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL
24200		K=1
24300		L=1
24400		LK=0
24500	221	NN=KPN(K)
24600		IF(Q(NN+1).LT.0)GO TO 321
24700		M=KPN(K+1)
24800	2	Q(L)=Q(NN)
24900		NN=NN+1
25000		IF(NN.GE.M)GO TO 1
25100		L=L+1
25200		GO TO 2
25300	1	LK=LK+1
25400		L=L+1
25500		KPN(LK+1)=L
25600	C SET NEXT POINTER
25700	321	K=K+1
25800		IF(K.LT.LLL)GO TO 221
25900		LLL=LK
26000		END
26100	
26200		SUBROUTINE SHFT1(KQ)
26300		COMMON /LLL/L /Q/Q(1) /XRN/RN(1) /PX/KPN(1) /IPG/IPG
26400		L=1
26500		K=1
26600	220	JJ=Q(K)+3
26700		KPN(L)=K
26800	C NEW POINTER
26900		IF(Q(K+1).NE.2.OR.Q(K).LT.6)GO TO 1
27000		JK=JJ+K
27100		IF(Q(JK+1).NE.10.OR.Q(JK).LT.6)GO TO 1
27200		IF(IPG.EQ.0)GO TO 1
27300	C do next only when extracting parts(IPG.NE.0)
27400		M=0
27500		KK=Q(JK)+2
27600		DO 2 N=K,K+KK+JK-1
27700		M=M+1
27800	2	RN(M)=Q(N)
27900		M=JK-K
28000		J=KK-JK
28100		KA=J+K
28200		NA=K
28300		B=RN(M+3)
28400	C  SAVE POS. (P3)
28500		DO 3 N=K,KA-1
28600		Q(N)=RN(M)
28700	3	M=M+1
28800		JK=K+J
28900		M=1
29000		A=RN(4)
29100	C POS OF THIS ITEM
29200		Q(NA+3)=A
29300		RN(4)=B
29400		DO 4 N=JK,KK-1
29500		Q(N)=RN(M)
29600	4	M=M+1
29700	C  ALL THIS TO FIND NUM AFTER REST.
29800	C GO BACK TO GET RIGHT PNTRS NOW.
29900		GO TO 220
30000	1	K=K+JJ
30100		IF(K.GE.KQ)GO TO 5
30200		L=L+1
30300		GO TO 220
30400	5	L=L+1
30500		KPN(L)=K
30600		END
30700	
30800		SUBROUTINE SHFT0(KQ)
30900		COMMON /LLL/L /XRN/RN(1) /Q/Q(1) /XXX/LK /PTR/KWDS(1)
31000		DO 32 K=1,KWDS(L)-1
31100		KQ=KQ+1
31200	32	Q(KQ)=RN(K)
31300		L=1
31400		LK=1
31500		END
31600	
31700		SUBROUTINE PSHFT(I)
31800		COMMON /SF/KL /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
31900		M=KPN(I+1)
32000		DO 31 NA=1,M
32100		RN(KL)=Q(NA)
32200	31	KL=KL+1
32300		END
34000	
35000		SUBROUTINE STAFF(P0,P1, P3,P4,P5,P6,P7,P8,P9,P10,P11,P12)
35100		COMMON/XRN/RN(1) /PTR/KWDS(1) /SF/KL,RT,KP
35200		KWDS(KP)=KL
35300		KP=KP+1
35400		RN(KL)=P0
35500		RN(KL+1)=P1
35600		RN(KL+2)=RT
35700		RN(KL+3)=P3
35800		RN(KL+4)=P4
35900		RN(KL+5)=P5
36000		IF(P0.LT.4.)GO TO 1
36100		RN(KL+6)=P6
36200		RN(KL+7)=P7
36300		RN(KL+8)=P8
36400		RN(KL+9)=P9
36500		RN(KL+10)=P10
36600		RN(KL+11)=P11
36700		RN(KL+12)=P12
36800	1	KL=KL+3+P0
36900		END
37000	
37100		FUNCTION RIGHT(NA,J,JK)
37200		COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL,LL,I
37300		K=NA+J
37400		N6=NJ
37500		IF(K.GT.0)GO TO 4
37600		RIGHT=Q(4)
37700		RETURN
37800	4	RX=Q(JK+3)
37900		R=Q(JK+2)
38000		JX=1
38100		IF(J.GT.0)JX=I  
38200	C FORWARD LOOP
38300	1	R8=CODEN(KPN,K,Q,LA)
38400		IF(R8.EQ.4)GO TO 2
38500	 	IF(Q(LA+2).NE.R)GO TO 3
38600		IF(R8.EQ.18..OR.R8.EQ.17.)GO TO 2
38700	C JUMP ON KEY SIG OR METER
38800	3	IF(K.EQ.JX)GO TO 5
38900		K=K+J
39000		GO TO 1
39100	5	IF(J.LE.0)RIGHT=RX
39200		RETURN  
39300	C SKIP NEXT IF GOING FORWARD IN LOOP (LOOKING TO RIGHT)
39400	C USE ITS OWN POS.-2 IF NOTHING FOUND TO LEFT
39500	C C NOW FOUND ITEM TO LEFT OR RT ON THIS STAFF.
39600	2	RIGHT=Q(LA+3)
39700		END
39800	
39900		SUBROUTINE RESTS
40000		COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL
40100		XLFT=0
40200		SIG=-99
40300		REST=0
40400		K=1
40500	50	JL=KPN(K)
40600		R=Q(JL+1)
40700		IF(XLFT.NE.0)GO TO 5
40800		IF(R.LE.4)XLFT=Q(JL+3)
40900		GO TO 3 
41000	5	IF(R.NE.17)GO TO 3
41100		IF(Q(JL+5).EQ.SIG)GO TO 60
41200		SIG=Q(JL+5)
41300	3	IF(R.NE.2)GO TO 231
41400		IF(Q(JL).GE.6)GO TO 7
41500		GO TO 231 
41600	7	IF(Q(JL+8).LE.-4)GO TO 231
41700		IF(Q(JL+7).LE.0)GO TO 231
41800	C (IGNORE NON-RHYTH.)
41900	C CATCH BAR REPEAT SIGN
42000		IF(Q(JL+8).EQ.0)GO TO 231
42100	C (WHOLE REST OVER CUE NOTES)
42200		IF(REST.NE.0)GO TO 6
42300		JR=JL+6
42400	C  POINTER TO REST NUM.
42500		R=Q(JR+1)
42600		IF(R.LT.5)R=5
42700		Q(JR+1)=R*.6
42800	C  REDUCE SIZE OF REST'S TIME SO IT WILL TAKE LESS SPACE.
42900	6	REST=REST+1.
43000		Q(JR+2)=REST
43100		Q(JR-2)=-2.
43200	C (LOWER THE REST'S POS.)
43300		JL=K+2
43400		IF(JL.GE.LLL)RETURN
43500		LB=KPN(JL)
43600		IF(Q(LB+1).NE.2)GO TO 233
43700	C NEXT IS TO COMBINE MEASURES OF REST
43800		IF(Q(LB).LT.6)GO TO 233
43900	C  SKIP NON-WHOLE RESTS
44000		N=KPN(JL-1)
44100		IF(Q(N+1).NE.4.)GO TO 233
44200	C  IS REST FOLLOWED BY A BAR?	OR RHRSL NUM?(COULD BE A PROB. HERE!!!)
44300	C SO IT WON'T BE FOUND NEXT TIME AROUND.
44400		Q(LB+1)=-1.
44500	C   CHANGE CODE #
44600		Q(N+1)=-1.
44700		K=JL
44800		GO TO 6
44900	60	Q(JL+1)=-1.
45000		GO TO 231
45100	233	REST=0
45200	231	K=K+1
45300		IF(K.LT.LLL)GO TO 50
45400		END
45500	
45600		SUBROUTINE EXCHG(M,N)
45700		DIMENSION M(2),N(2)
45800		J=M(1)
45900		M(1)=M(2)
46000		M(2)=J
46100		J=N(1)
46200		N(1)=N(2)
46300		N(2)=J
46400		END
46500	
46600		SUBROUTINE EXCH(J,K)
46700		L=J
46800		J=K
46900		K=L
47000		END	
47100	
47200		SUBROUTINE INMUS(NAME,EXT,RN,KWDS,JSTFAC)
47300		DIMENSION RN(1),KWDS(1),JSTFAC(1)
47400		CALL GETEXT(NAME,EXT)
47500		CALL EXTIN(JSTFAC,20)
47600	C READ ONLY 20 WDS IN PAGE ONLY****** NOT [=128]  
47700		JJ=JSTFAC(19)
47800	C JSTFAC(19) = THE WD CNT.
47900	C ********** CHANGE JSTFAC ARRAY FOR PDP11 ***************
48000		CALL EXTIN(RN,JJ)
48100	C	MOVE @15	;@R		;IF(R(1).NE.INTEGER 1)GO TO I3
48200	C	CAIE 1		;OLD FORMAT ?    ***** ASSUMES NEW FORMAT (NO KWDS ARRAY)
48300	C	JRST I3		;NO
48400	C	USETI 12,2	;YES, READ 2ND RECORD AGAIN   (12 =CH)
48500	C	JSA 16,EXTIN  	;CALL EXTIN(RS,128)
48600	C	JUMP @12	;JUMP @KW
48700	C	JUMP =17(11)	;JUMP NWDS    	;CALL EXTIN(K,J)
48800	C	JRST I1		;GO BACK AND GET R ARRAY
48900	3	N=1 
49000		L=1
49100		KWDS(1)=1
49200	4	N=N+RN(N)+3
49300	C   HERE'S THE LOOP 
49400	C GET WD CNT -2
49500		L=L+1
49600	C  UPDATE THE COUNTER OF THE POINTER LIST
49700		KWDS(L)=N
49800		IF(N.LT.JJ)GO TO 4
49900		END
50000	
50100		FUNCTION RCURVE(R)
50200		DIMENSION R(1)
50300	C R(1) IS R3   R(4) IS R6, ETC.
50400		X=R(4)-R(1)
50500		RCURVE=R(6)+1.
50600		IF(RCURVE.LT.0)X=X+RCURVE+RCURVE
50700		X=X/25.
50800	C R8=-2=BETWEEN NOTES, =-3=1ST NOTE IS DOTTED.
50900		RCURVE=X+2.+ABS(R(3)-R(2))/10.
51000		IF(R(5).LT.0)RCURVE=-RCURVE
51100	C IF(R7 WAS .LT.0)KEEP IT NEGATIVE.
51200		END
51300	
51400		SUBROUTINE SHRNK(K,IT)
51500		COMMON R2,JA,REST,J2,R3,R4,R5,R6,R7,R8,R9
51600		COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL,LL,I
51700		L10=IT-1
51800		L11=KPN(IT+1)
51900	C END OF Q DATA
52000	C	X=Q(L+3)
52100		K2=K
52200		K12=K2
52300		K3=KPN(K2)
52400		K6=K3
52500	C	A13=Q(K3+3)
52600	 	R8=Q(K3+3)
52700	C POS. OF CLEF TO BE MOVED.
52800		K4=KPN(K2+1)
52900	C PTR TO NEXT ITEM
53000		K1=K4
53100		K3=K3-K4
53200	C WDCNT OF DELETE ITEM
53300		K4=K4-KPN(K2+2)
53400	C NEXT +1
53500		K3=K3-K4
53600	C AMOUNT OF CHANGE
53700	C1	K5=KPN(K2+2)
53800	C	K5=K5-KPN(K2+1)
53900	C	K5=K5+KPN(K2)
54000	C	KPN(K2+1)=K5
54100	1	KPN(K2+1)=KPN(K2+2)-KPN(K2+1)+KPN(K2)
54200	
54300		IF(K2.EQ.L10)GO TO 4
54400		K2=K2+1
54500		GO TO 1
54600	4	K2=KPN(K2+1)
54700	C LAST PTR
54800	C	A7=Q(K6+3)
54900		R4=Q(K6+3)
55000	C POS FOR LATER "MOVE"
55100	2	Q(K6)=Q(K1)
55200		K1=K1+1
55300		IF(K1.EQ.L11)GO TO 5
55400		K6=K6+1
55500		GO TO 2
55600	5	IT=L10
55700		I=L10
55800	C I=LEND (FOR FINAL ENDPOINT)
55900	C	R4=A7
56000	C	R8=A13
56100	C R8=EXPAND REMAINDER OF LINE TO CLEF POS.
56200	6	LL=0
56300	C LL=0 (NO JUSTIFY)
56400		R5=200.
56500		R2=0
56600		R9=R5
56700		R7=0
56800		CALL PTMOVE(Q,KPN(K12))
56900		END
57000	
57100	C	SUBROUTINE EXPND(J)
57200	CC TO SHIFT LINE TO RT. WHEN ADDING KSIG.
57300	C	COMMON/STF/RSTFAC(8),RSTJ2 
57400	C	COMMON R2,JA,REST,J2,R3,R4,R5,R6,R7,R8,R9
57500	C	COMMON /PX/KPN(1) /Q/Q(1) /LLL/LLL,LL,I
57600	CC??	A5=5.
57700	C	R4=7.1*RSTJ2
57800	C	K12=J+2
57900	CC GET PTR TO KPN   ADD 2 (FOR NOW, ANYWAY)
58000	C	R8=0
58100	CC  GO MOVE IT
58200	C6	LL=0
58300	CC LL=0 (NO JUSTIFY)
58400	C	R5=200.
58500	C	R2=0
58600	C	R9=R5
58700	C	R7=0
58800	C	CALL PTMOVE(Q,KPN(K12))
58900	C	END